home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Graphical 187284232001.psc / ForeColor.bas < prev    next >
Encoding:
BASIC Source File  |  2001-04-22  |  8.2 KB  |  208 lines
  1. Attribute VB_Name = "ButtonForeColor"
  2. '==================================================================
  3. '
  4. '   Found at Visual Basic Thunder, www.vbthunder.com
  5. '   and modified by Ulli
  6. '
  7. '   This module provides an easy way to change the text color
  8. '   of a VB CommandButton control. To use the code with a
  9. '   CommandButton, you should:
  10. '
  11. '   - Set the button's Style property to "Graphical" at design time.
  12. '
  13. '   - Optionally set its BackColor and Picture properties.
  14. '
  15. '   - Call SetButtonForeColor in the Form_Load event:
  16. '       SetButtonForeColor Command1, vbBlue, Alignment
  17. '       (You can do this multiple times during your program's
  18. '       execution, even without calling UnsetButtonForeColor.)
  19. '
  20. '   - Call UnsetButtonForeColor in the Form_Unload event:
  21. '       UnsetButtonForeColor Command1
  22. '
  23. '   Unfortunately this works only for single line captions
  24. '==================================================================
  25. Option Explicit
  26.  
  27. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  28. Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  29. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  30. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  31. Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  32. Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
  33. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
  34. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  35. Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  36. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  37. Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  38. Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
  39.  
  40. Private Const TRANSPARENT   As Long = 1
  41. Private Const GWL_WNDPROC   As Long = -4
  42. Private Const ODT_BUTTON    As Long = 4
  43. Private Const ODS_SELECTED  As Long = &H1
  44. Private Const WM_DESTROY    As Long = &H2
  45. Private Const WM_DRAWITEM   As Long = &H2B
  46. Private Const DT_HCENTER    As Long = &H1
  47. Private Const DT_TOP        As Long = &H0
  48. Private Const DT_VCENTER    As Long = &H4
  49. Private Const DT_BOTTOM     As Long = &H8
  50. Private Const DT_SINGLELINE As Long = &H20
  51. 'chris added
  52. Private Const DT_WORDBREAK As Long = &H10
  53. Public Const DT_CHARSTREAM = 4          '  Character-stream, PLP
  54. Public Const DT_EXPANDTABS = &H40
  55. Public Const DT_EXTERNALLEADING = &H200
  56. Public Const DT_LEFT = &H0
  57. Public Const DT_NOCLIP = &H100
  58. Public Const DT_CENTER As Long = &H1
  59. Public Const DT_CALCRECT = &H400
  60. Public Const DT_INTERNAL = &H1000
  61.  
  62. Public Const TA_CENTER = 6
  63. Public Const TA_UPDATECP = 1
  64. Public Const TA_BASELINE = 24
  65. Public Const DT_METAFILE = 5            '  Metafile, VDM
  66. Public Const DT_PLOTTER = 0             '  Vector plotter
  67. Public Const DUPLICATE = &H6
  68.  
  69. Public Const WM_GETTEXT = &HD
  70. Public Const WM_GETMINMAXINFO = &H24
  71. Public Const WM_GETFONT = &H31
  72. Public Const WM_COPY = &H301
  73. Public Const WM_GETTEXTLENGTH = &HE
  74. Public Const WM_COPYDATA = &H4A
  75. Public Const WM_PASTE = &H302
  76.  
  77. Private Type RECT
  78.     Left        As Long
  79.     Top         As Long
  80.     Right       As Long
  81.     Bottom      As Long
  82. End Type
  83.  
  84. Private Type DRAWITEMSTRUCT
  85.     CtlType     As Long
  86.     CtlID       As Long
  87.     ItemID      As Long
  88.     ItemAction  As Long
  89.     ItemState   As Long
  90.     hWndItem    As Long
  91.     hDC         As Long
  92.     rcItem      As RECT
  93.     ItemData    As Long
  94. End Type
  95.  
  96. Public Enum AlignText
  97.     AlignTop = DT_TOP
  98.     AlignCenter = DT_VCENTER
  99.     AlignBottom = DT_BOTTOM
  100.     ThreeD = DT_VCENTER Or DT_BOTTOM
  101. End Enum
  102.  
  103. 'property names
  104. Private Const PropCustom = "UMGCustom"
  105. Private Const PropForeColor = "UMGForeColor"
  106. Private Const PropAlign = "UMGVAlign"
  107. Private Const PropSubclass = "UMGDrawProc"
  108.  
  109. Public Sub SetForeColor(Button As CommandButton, ByVal ForeColor As OLE_COLOR, Optional ByVal Alignment As AlignText = AlignCenter)
  110.  
  111.   Dim hWndPnt   As Long
  112.     
  113.     With Button
  114.         hWndPnt = GetParent(.hWnd)
  115.         If GetProp(hWndPnt, PropSubclass) = 0 Then 'not yet subclassed
  116.             SetProp hWndPnt, PropSubclass, GetWindowLong(hWndPnt, GWL_WNDPROC)
  117.             SetWindowLong hWndPnt, GWL_WNDPROC, AddressOf DrawButtonProc
  118.         End If
  119.         SetProp .hWnd, PropCustom, True
  120.         SetProp .hWnd, PropForeColor, ForeColor
  121.         SetProp .hWnd, PropAlign, Alignment
  122.         .Refresh
  123.     End With
  124.  
  125. End Sub
  126.  
  127. Public Sub UnsetForeColor(Button As CommandButton)
  128.  
  129.     With Button
  130.         RemoveProp .hWnd, PropCustom
  131.         RemoveProp .hWnd, PropForeColor
  132.         RemoveProp .hWnd, PropAlign
  133.         .Refresh
  134.     End With
  135.  
  136. End Sub
  137.  
  138. Private Function DrawButtonProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  139.  
  140.   Dim lOldProc  As Long
  141.   Dim di        As DRAWITEMSTRUCT
  142.   Dim s         As String
  143.   Dim VA        As AlignText
  144.  
  145.     lOldProc = GetProp(hWnd, PropSubclass)
  146.     DrawButtonProc = CallWindowProc(lOldProc, hWnd, wMsg, wParam, lParam)
  147.     Select Case wMsg
  148.       Case WM_DRAWITEM
  149.         CopyMemory di, ByVal lParam, Len(di)
  150.         With di
  151.             If .CtlType = ODT_BUTTON Then
  152.                 If GetProp(.hWndItem, PropCustom) Then
  153.                     VA = GetProp(.hWndItem, PropAlign)
  154.                     With .rcItem
  155.                         Select Case VA
  156.                           Case DT_TOP
  157.                             .Top = .Top + 4
  158.                           Case DT_BOTTOM
  159.                             .Bottom = .Bottom - 4
  160.                           Case ThreeD
  161.                             .Left = .Left - 1
  162.                             .Top = .Top - 1
  163.                             .Right = .Right - 1
  164.                             .Bottom = .Bottom - 1
  165.                             VA = AlignCenter
  166.                         End Select
  167.                         If (di.ItemState And ODS_SELECTED) = ODS_SELECTED Then
  168.                             'Button is in down state - offset the text
  169.                             .Left = .Left + 1
  170.                             .Top = .Top + 1
  171.                             .Right = .Right + 1
  172.                             .Bottom = .Bottom + 1
  173.                             End If
  174.                     End With
  175.                     SetBkMode .hDC, TRANSPARENT
  176.                     s = String$(255, 0)
  177.                     GetWindowText .hWndItem, s, Len(s)
  178.                     s = Left$(s, InStr(s, Chr$(0)) - 1)
  179.                     SetTextColor .hDC, GetProp(.hWndItem, PropForeColor)
  180.                     'Command52 was chosen as the
  181.                     'multi line button, let's do
  182.                     'all the others first
  183.                     '(Command52's ID# is 5)
  184.                     
  185.                     
  186.                     If di.CtlID <> 5 Then
  187.                     DrawText .hDC, s, Len(s), .rcItem, DT_SINGLELINE Or DT_HCENTER Or VA
  188.                     Else
  189.                     
  190.                     With .rcItem
  191.                     .Top = .Top + 1
  192.                     End With
  193.                     'draw the multi line text.
  194.                     
  195.                     DrawText .hDC, s, Len(s), .rcItem, DT_WORDBREAK Or TA_CENTER Or DT_HCENTER
  196.                     End If
  197.                 End If
  198.             End If
  199.         End With
  200.       Case WM_DESTROY
  201.         If lOldProc Then 'is subclassed
  202.             SetWindowLong hWnd, GWL_WNDPROC, lOldProc
  203.             RemoveProp hWnd, PropSubclass
  204.         End If
  205.     End Select
  206.  
  207. End Function
  208.